home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / v3 / modlib_s.lha / modlib_src / $db.P < prev    next >
Text File  |  1990-04-12  |  18KB  |  456 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* $db.P */
  25. /* Last modification: Aug 25, 1989 -- Paco Romero */
  26. /*
  27. These are the basic routines that support assert and retract in our system.
  28.  
  29. The system supports a concept of a Prref, a predicate reference.
  30. A Prref is a database reference to a sequence of asserted clauses.
  31. Normally a Prref is associated with a psc-entry (in the e.p.  field),
  32. the psc entry of the main functor symbol of all the clauses.  But that
  33. need not be the case. A Prref can be created, asserted to, and
  34. called explicitly. 
  35.  
  36. The system also supports a concept of Clref, a clause reference.
  37. These are quite similar to the db references in CProlog.  A Clref is
  38. a reference to a single clause.  A Clref can also be called.
  39. Normally a Clref is chained into a Prref.  
  40. */
  41.  
  42. $db_export([$db_new_prref/1,$db_assert_fact/5,
  43.             $db_assert_fact/7, $db_add_clref/6,
  44.             $db_call_prref/2,$db_call_prref_s/2,$db_call_prref_s/3,
  45.             $db_call_clref/2,$db_get_clauses/3,$db_kill_clause/1]).
  46.  
  47. $db_use($dbcmpl,[$db_cmpl/5,$db_putbuffop/4,
  48.                  $db_putbuffbyte/4,$db_putbuffnum/4]).
  49.  
  50. $db_use($buff, [$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,
  51.                 $symtype/2,$substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  52.         $pred_undefined/1, $hashval/3]).
  53.  
  54. $db_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  55.                 $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$floor/2]).
  56.  
  57.  
  58. $db_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,$tell/1,$tell/2,
  59.               $telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,$seen/0]).
  60.  
  61.  
  62. /* $db_new_prref(Prref):  creates an empty Prref, i.e.  one with no
  63. clauses in it.  If called, it will simply fail.  Prref must be a
  64. variable at the time of call.  */
  65.  
  66. $db_new_prref(Prref) :- $db_new_prref(Prref,0,0).
  67. $db_new_prref(Prref,Where,Supbuff) :-
  68.     $alloc_buff(20,Prref,Where,Supbuff,0),
  69.         /* disp 16 for pointer to last clause */
  70.         $opcode( fail, FailOp ),
  71.     $buff_code(Prref,  0, 14 /*ptv*/ ,Prref), /*set back pointer*/
  72.     $buff_code(Prref,  4,  3 /*ps*/ ,FailOp /* fail*/ ),
  73.     $buff_code(Prref,  6,  3 /*ps*/ ,0),
  74.     $buff_code(Prref, 12,  3 /*ps*/ ,FailOp /* fail*/ ),
  75.     $buff_code(Prref, 14,  3 /*ps*/ ,0).
  76.  
  77.  
  78.  
  79. /* $db_assert_fact(Fact,Prref,AZ,Index,Clref):  where Fact is a fact to
  80. be asserted; Prref is a predicate reference to which to add the
  81. asserted fact; AZ is either 0 indicating the fact should be inserted
  82. as the first clause in Prref, or 1 indicating it should be inserted
  83. as the last; Index is 0 if no index is to be built, or n if an index
  84. on the nth argument of the fact is to be used; Clref is returned and
  85. it is the clause reference of the asserted fact. */
  86.  
  87. $db_assert_fact(Fact,Prref,AZ,Index,Clref) :- 
  88.     $db_assert_fact(Fact,Prref,AZ,Index,Clref,0,0).
  89.  
  90. $db_assert_fact(Clause,Prref,AZ,Index,Clref,Where,Supbuff) :- 
  91.     $db_cmpl(Clause,Clref,Index,Where,Supbuff),
  92.     (var(Prref) -> $db_new_prref(Prref,Where,Supbuff) ; true),
  93.     (Clause = (Head:-_) -> ($arity(Head,Arity));
  94.             (Clause=Head, $arity(Head,Ar1),Arity is Ar1+1)
  95.     ),
  96.     $db_add_clref(Head,Arity,Prref,AZ,Index,Clref,Where,Supbuff).
  97.  
  98. /* $db_add_clref(Fact,Arity,Prref,AZ,Index,Clref) adds a clause buffer to a
  99. prref. So Prref and Clref must be bound. Arity is the number of registers
  100. to save in a choice point (if Fact is a fact, it is Arity(Fact)+1, for cut)
  101. The other parameters are as above.
  102. */
  103.  
  104. $db_add_clref(Fact,Arity,Prref,AZ,Index,Clref) :-
  105.     $db_add_clref(Fact,Arity,Prref,AZ,Index,Clref,0,0).
  106. $db_add_clref(Fact,Arity,Prref,AZ,Index,Clref,Where,Supbuff) :-
  107.     Index =< 0 ->
  108.       (AZ =:= 0 ->
  109.         $db_addbuffa(Arity,Clref,Prref);
  110.         $db_addbuffz(Arity,Clref,Prref));
  111.       (AZ =:= 0 -> 
  112.         $writename('Indexed add to beginning not supported'),$nl,fail
  113.        ;
  114.         ((arg(Index, Fact, Arg), nonvar(Arg)) ->
  115.               $db_addbuffz_i(Arity,Clref,Prref,Index,Arg,Where,Supbuff) ;
  116.               $db_addbuffz(Arity,Clref,Prref)
  117.         )
  118.       ).
  119.  
  120. /* Add Clref to empty Prref */
  121. $db_addbuffonly(Arity,Clref,Prref) :-
  122.          $opcode( jumptbreg, JmpOp ),
  123.      $buff_code(Prref,  4,  3 /*ps*/ ,JmpOp /*jump and save breg */ ),
  124.      $buff_code(Prref,  6,  3 /*ps*/ ,Arity),
  125.      $buff_code(Prref,  8, 10 /*pbr*/ ,Clref),
  126.      $buff_code(Prref, 16, 10 /*pbr*/ ,Clref), /* ptr to last clause */
  127.          $opcode( noop, NoopOp ),
  128.      $buff_code(Clref,  4,  3 /*ps*/ ,NoopOp /*noop*/ ),
  129.      $buff_code(Clref,  6,  3 /*ps*/ ,2).
  130.  
  131. /* add Clref to end of Prref */
  132. $db_addbuffz(Arity,Clref,Prref) :-
  133.         /* Prref must be dummy header */
  134.         $opcode( fail, FailOp ),
  135.     $buff_code(Prref, 4, 6 /*gs*/ ,Op),
  136.     (Op =:= FailOp,   /*fail*/
  137.      $db_addbuffonly(Arity,Clref,Prref)
  138.     ;
  139.      Op =\= FailOp,   /*fail*/
  140.       ($opcode( jumptbreg, JmpOp ),
  141.            Op =:= JmpOp,   /* must be a jump-and-save-breg to next clause */
  142.        $buff_code(Prref, 16, 8 /*gpb*/ ,Lbuff), /* last buff */
  143.        $buff_code(Lbuff,  4, 6 /*gs*/ ,Sop),
  144.            $opcode( noop, NoopOp ),
  145.            $opcode( trustmeelsefail, TrustOp ),
  146.        (Sop =:= NoopOp, /* noop, change to try */
  147.             $opcode( trymeelse, TryOp ),
  148.         $buff_code(Lbuff, 4, 3 /*ps*/ ,TryOp /*trymeelse*/)
  149.        ;
  150.         Sop =\= NoopOp,
  151.         Sop =:= TrustOp,    /* must be a trustmeelsefail */
  152.             $opcode( retrymeelse, RetryOp ),
  153.         $buff_code(Lbuff, 4, 3 /*ps*/ ,RetryOp /*retrymeelse*/)
  154.        ),
  155.        $buff_code(Lbuff,  6,  3 /*ps*/ ,Arity),
  156.        $buff_code(Lbuff,  8, 10 /*pbr*/ ,Clref),
  157.        $buff_code(Clref,  4,  3 /*ps*/ ,TrustOp /*trustmeelsefail*/ ),
  158.        $buff_code(Clref,  6,  3 /*ps*/ ,Arity),
  159.        $buff_code(Clref,  8,  3 /*ps*/ ,NoopOp /*noop*/ ),
  160.        $buff_code(Clref, 10,  3 /*ps*/ ,0),
  161.        $buff_code(Prref, 16, 10 /*pbr*/ ,Clref) /* point to new last */
  162.       )
  163.     ).
  164.  
  165.  
  166. /* add a buffer to the beginning of the chain */
  167. $db_addbuffa(Arity,Clref,Prref) :-
  168.         $opcode( fail, FailOp ),
  169.     $buff_code(Prref, 4, 6 /*gs*/ ,Op),
  170.     (Op =:= FailOp,                /* fail */
  171.         /* only dummy clause there */
  172.      $db_addbuffonly(Arity,Clref,Prref)
  173.     ;
  174.      Op =\= FailOp,
  175.       ($opcode( jumptbreg, JmpOp ),
  176.        $opcode( trymeelse, TryOp ),
  177.            Op =:= JmpOp,   /* must be a jump-and-save-breg, otw fail */
  178.        $buff_code(Prref, 8, 8 /*gpb*/ ,Sbuff), /* next buff */
  179.        $buff_code(Sbuff, 4, 6 /*gs*/ ,Sop),
  180.            $opcode( noop, NoopOp ),
  181.        (Sop =:= NoopOp, /* noop, change to trust */
  182.         $opcode( trustmeelsefail, TrustOp ),
  183.         $buff_code(Sbuff,  4, 3 /*ps*/ ,TrustOp ),
  184.         $buff_code(Sbuff,  6, 3 /*ps*/ ,Arity),
  185.         $buff_code(Sbuff,  8, 3 /*ps*/ ,NoopOp /*noop*/ ),
  186.         $buff_code(Sbuff, 10, 3 /*ps*/ ,0)
  187.        ;
  188.         Sop =\= NoopOp, /* not noop */
  189.         Sop =:= TryOp, /* must be try, else fail */
  190.         $opcode( retrymeelse, RetryOp ),
  191.         $buff_code(Sbuff, 4,3  /*ps*/ ,RetryOp ) /* make retry */
  192.        ),
  193.        $buff_code(Prref, 8, 10 /*pbr*/, Clref), /* point first to new */
  194.        $buff_code(Clref, 4,  3 /*ps*/ , TryOp /*trymeelse*/), 
  195.        $buff_code(Clref, 6,  3 /*ps*/ , Arity),
  196.        $buff_code(Clref, 8, 10 /*pbr*/, Sbuff) /* point new to old 2nd*/
  197.      )
  198.     ).
  199.  
  200. /* adds a buffer to an index chain */
  201. $db_addbuffz_i(Arity,Clref,Prref,Index,Arg,_,_) :-
  202.         $opcode( fail, FailOp ),
  203.         $opcode( noop, NoopOp ),
  204.         $opcode( switchonbound, SobOp ),
  205.     $buff_code(Prref,  4, 6 /*gs*/ ,Op),
  206.         Op =\= FailOp, /* fail if no clrefs */
  207.     $buff_code(Prref, 16, 8 /*gpb*/ ,Lbuff),  /* last buff */
  208.     $buff_code(Lbuff, 12, 6 /*gs*/ ,NoopOp),  /* noop if SOB */
  209.     $buff_code(Lbuff, 20, 6 /*gs*/ ,SobOp),   /* op code must be sob */
  210.     $buff_code(Lbuff, 22, 6,Index),          /* must be same arg */
  211.     !,
  212.     $buff_code(Lbuff, 28, 5 /*gn*/, N), /* tabsize */
  213.     $db_proc_all_chain(Arity,Lbuff,Clref),
  214.     $db_proc_hash_chain(Arg,Arity,Lbuff,Clref,N).
  215.  
  216. $db_addbuffz_i(Arity,Clref,Prref,Index,Arg,Where,Supbuff) :-
  217.          /* must add new sop buffer */
  218.     $db_create_sob(Sbuff,N,Where,Supbuff), /* get sob buffer */
  219.     $db_gen_sobcode(Index, Sbuff, Clref, N),
  220.     $db_proc_hash_chain(Arg, Arity, Sbuff, Clref, N),
  221.     $db_addbuffz(Arity,Sbuff,Prref).
  222.  
  223. $db_create_sob(Sbuff,N,Where,Supbuff) :-
  224.     '_$tab_size'(N), Size is 12 + 8 + 12 + 8 + 4 * N + 4,
  225.     $alloc_buff(Size,Sbuff,Where,Supbuff,0),
  226.     $buff_code(Sbuff, 0, 14 /*ptv*/, Sbuff). /* backptr */
  227.  
  228. $db_gen_sobcode(Narg, Sbuff, Clref, N) :-
  229.         $opcode( noop, NoopOp ),
  230.         $opcode( switchonbound, SobOp ),
  231.         $opcode( jump, JumpOp ),
  232.         $buff_code(Sbuff, 12, 3 /*ps*/ , NoopOp /*noop*/),
  233.         $buff_code(Sbuff, 14, 3 /*ps*/ , 2),
  234.     $buff_code(Sbuff, 16, 10 /*pbr*/ ,Clref),
  235.         $buff_code(Sbuff, 20, 3 /*ps*/ , SobOp /*switchonbound*/),
  236.         $buff_code(Sbuff, 22, 3 /*ps*/ , Narg),
  237.         $buff_code(Sbuff, 40, 33, AddrTab), /* get addr of tab */
  238.         $buff_code(Sbuff, 24, 32, AddrTab), /* store addr of tab */
  239.         $buff_code(Sbuff, 28, 2, N /* size of hashtab */),
  240.         $buff_code(Sbuff, 32, 3 /*ps*/ , JumpOp /* jump */),
  241.         $buff_code(Sbuff, 34, 3 /*ps*/ , 0),
  242.         $buff_code(Sbuff, 36, 10, Clref),
  243.         $buff_code(Clref,  4, 3 /*ps*/, NoopOp /*noop*/),
  244.         $buff_code(Clref,  6, 3 /*ps*/, 2),
  245.         $db_init_tab(Sbuff, N).
  246.  
  247. $db_init_tab(Clref, N) :-
  248.         Disp is 40 + 4 * N, 
  249.         $opcode( fail, FailOp ),
  250.         $buff_code(Clref, Disp, 3 /*ps*/ , FailOp /*fail*/),
  251.         Disp1 is Disp + 2,
  252.         $buff_code(Clref, Disp1, 3 /*ps*/ , 0),
  253.         $buff_code(Clref, Disp, 33, FailAddr),
  254.         $db_init_hashtab(0, 40, N, Clref, FailAddr).
  255.  
  256. $db_init_hashtab(N, Lin, Size, Clref, FailAddr) :-
  257.         N >= Size;
  258.         N < Size,
  259.         $buff_code(Clref, Lin, 32 /* word num */, FailAddr),
  260.         Lout is Lin + 4,
  261.         N1 is N + 1,
  262.         $db_init_hashtab(N1, Lout, Size, Clref, FailAddr).
  263.  
  264. $db_proc_all_chain(Arity, Sbuff, Clref) :-
  265.         $opcode( noop, NoopOp ),
  266.         $opcode( trustmeelsefail, TrustOp ),
  267.         $buff_code(Sbuff, 16, 8, Lbuff), /* last buff on all chain */
  268.     $buff_code(Lbuff,  4, 6 /*gs*/ ,Sop),
  269.     (Sop =:= NoopOp, /* noop, change to try */
  270.         $opcode( trymeelse, TryOp ),
  271.     $buff_code(Lbuff, 4, 3 /*ps*/ ,TryOp /*trymeelse*/)
  272.     ;
  273.      Sop =\= NoopOp,
  274.      Sop =:= TrustOp,        /* must be a trustmeelsefail */
  275.          $opcode( retrymeelse, RetryOp ),
  276.      $buff_code(Lbuff, 4, 3 /*ps*/ , RetryOp /*retrymeelse*/)
  277.     ),
  278.     $buff_code(Lbuff,  6,  3 /*ps*/ ,Arity),
  279.     $buff_code(Lbuff,  8, 10 /*pbr*/ ,Clref),
  280.     $buff_code(Clref,  4,  3 /*ps*/ ,TrustOp /*trustmeelsefail*/ ),
  281.     $buff_code(Clref,  6,  3 /*ps*/ ,Arity),
  282.      $buff_code(Clref,  8,  3 /*ps*/ ,NoopOp /*noop*/ ),
  283.     $buff_code(Clref, 10,  3 /*ps*/ ,0), 
  284.     $buff_code(Sbuff, 16, 10 /*pbr*/ ,Clref). /* point to new last */
  285.  
  286. $db_proc_hash_chain(Arg, Arity, Tbuff, Buff, N) :-
  287.         nonvar(Arg), 
  288.         $hashval(Arg, N, Hashval),
  289.         Bucket is 40 + 4 * Hashval,
  290.         $buff_code(Tbuff, Bucket, 5, Addr),
  291.         Faild is 40 + 4 * N,
  292.         $buff_code(Tbuff, Faild, 33, Faddr),
  293.         ((Addr = Faddr, $db_link_first(Bucket, Tbuff, Buff), !);
  294.          ($db_get_hash_next(Bucket, Tbuff, NextBuff, Disp, B),
  295.           $db_link_all(Arity, NextBuff, Disp, Buff, B))
  296.         ).
  297.  
  298. $db_link_first(Bucket, Tbuff, Buff) :-
  299.         $db_get_addr(Buff, _, Hash_addr),
  300.         $buff_code(Tbuff, Bucket, 32, Hash_addr).
  301.  
  302.  
  303. $db_get_addr(Buff, Disp, Hash_addr) :-
  304.         $conlength(Buff, Len),
  305.         Disp is Len - 16,
  306.         $buff_code(Buff, Disp, 33, Hash_addr).
  307.  
  308. $db_get_hash_next(Bucket, Tbuff, NextBuff, Disp, B) :-
  309.         /* get buffer pointed to by the bucket        */
  310.         $buff_code(Tbuff, Bucket, 21 /* gnb */, NextBuff), 
  311.         $conlength(NextBuff, Len),
  312.         Disp is Len - 16,
  313.         $buff_code(NextBuff, Disp, 6 /*gb*/ , B).
  314.  
  315. $db_link_all(Arity, NextBuff, Disp, Buff, B) :-
  316.         $opcode( noop, NoopOp ),
  317.         $opcode( trymeelse, TryOp ),
  318.         ((B =:= NoopOp, /* noop */
  319.           $db_putbuffop( TryOp /* trymeelse */, NextBuff, Disp, L1),
  320.           $db_putbuffbyte(Arity, NextBuff, L1, L2),
  321.           $db_get_addr(Buff, BuffDisp, Hash_addr),
  322.           $db_putbuffnum(Hash_addr, NextBuff, L2, _),
  323.           $db_set_index_trust(Arity, Buff, BuffDisp));
  324.          (B =\= NoopOp, 
  325.           B =:= TryOp, /* trymeelse */
  326.           Loc is Disp + 4,
  327.           $db_get_hash_next(Loc, NextBuff, Clref, NewDisp, NewB),
  328.           $db_link_rest(Arity, Clref, NewDisp, Buff, NewB))
  329.         ).
  330.  
  331. $db_link_rest(Arity, NextBuff, Disp, Buff, B) :-
  332.         $opcode( retrymeelse, RetryOp ),
  333.         ((B =:= RetryOp, /* retrymeelse */
  334.           Loc is Disp + 4,
  335.           $db_get_hash_next(Loc, NextBuff, Clref, NewDisp, NewB),
  336.           $db_link_rest(Arity, Clref, NewDisp, Buff, NewB));
  337.          (B =\= RetryOp, 
  338.           $opcode( trustmeelsefail, TrustOp ),
  339.           B =:= TrustOp, /* trustmeelsefail */
  340.           $db_get_addr(Buff, BDisp, Hash_addr),
  341.           $db_set_index_retry(Arity, NextBuff, Disp, Hash_addr),
  342.           $db_set_index_trust(Arity, Buff, BDisp))
  343.         ).
  344.  
  345. $db_set_index_trust(Arity, Buff, Disp) :-
  346.         $opcode( trustmeelsefail, TrustOp ),
  347.         $opcode( noop, NoopOp ),
  348.         $db_putbuffop( TrustOp, Buff, Disp, L1),
  349.         $db_putbuffbyte(Arity, Buff, L1, L2),
  350.         $db_putbuffop( NoopOp, Buff, L2, L3),
  351.         $db_putbuffbyte(0, Buff, L3, _).
  352.  
  353. $db_set_index_retry(Arity, Buff, Disp, Addr) :-
  354.         $opcode( retrymeelse, RetryOp ),
  355.         $db_putbuffop( RetryOp, Buff, Disp, L1),
  356.         $db_putbuffbyte(Arity, Buff, L1, L2),
  357.         $db_putbuffnum(Addr, Buff, L2, _).
  358.  
  359.  
  360. /* $db_call_prref(Call,Prref):  where Call is a literal and Prref is a
  361. predicate reference.  This calls the Prref using Call as the call.
  362. The call is done by simply branching to the first clause.  Thus the
  363. trust optimization is used, and so new facts added to the Prref after
  364. the last fact is retrieved but before the call is failed through will
  365. NOT be used. */
  366.  
  367. $db_call_prref(Call,Prref) :- $buff_code(Prref,4,13 /*execb*/ ,Call).
  368.  
  369.  
  370. /* $db_call_prref_s(Call,Prref):  with the same arguments as the
  371. previous and also calling the clauses.  The difference from 
  372. $db_call_prref is that it does not use the trust optimization so that any
  373. new fact addd before final failure will be used.  */
  374.  
  375. $db_call_prref_s(Goal,Prref) :- $db_call_prref_s(Goal,Prref,_).
  376.  
  377. /* same as above, but also returns cl_ref of successful clause */
  378. $db_call_prref_s(Goal,Prref,Cur_clref) :-
  379.     $db_get_first_clref(Prref,Clref),$db_get_clrefs(Clref,Cur_clref,0),
  380.     $db_call_clref(Goal,Cur_clref).
  381.  
  382.  
  383. /* $db_call_clref(Call,Clref): will call the clause referenced by Clref
  384. using the literal Call as the call. */
  385.  
  386. $db_call_clref(Call,Clref) :- $buff_code(Clref,12,13 /*execb*/ ,Call).
  387.  
  388.  
  389. /* $db_get_clauses(Prref,Clref,Dir): This returns nondeterministically all
  390. the clause references for clauses asserted to Prref. If Dir is 0, then
  391. the first on the list is returned first; if Dir is 1, then they are 
  392. returned in reverse order.
  393. */
  394.  
  395. $db_get_clauses(Prref,Clref,Dir) :- 
  396.     $db_get_first_clref(Prref,Fclref),
  397.     $db_get_clrefs(Fclref,Clref,Dir).
  398.  
  399.  
  400. /* given a pr_ref, get the cl_ref for the first clause. */
  401. $db_get_first_clref(Prref,Clref) :-
  402.         $opcode( jumptbreg, JmpOp ),
  403.     $buff_code(Prref, 4, 6 /*gs*/ , JmpOp), /* must be jump-and-save-breg */
  404.     $buff_code(Prref, 8, 8 /*gpb*/ ,Clref).
  405.  
  406. /* return, through backtracking, the sequence of cl_refs chained from
  407. the given one, returning given one first */
  408.  
  409. $db_get_clrefs(Clref,N_clref,1) :- 
  410.     $db_get_next_clref(Clref,Nxt_clref),
  411.     $db_get_clrefs(Nxt_clref,N_clref,1).
  412.  
  413. $db_get_clrefs(Clref,N_clref,Dir) :-
  414.     $buff_code(Clref,12,6 /*gs*/ ,Nop),         /* if sob, is noop */
  415.         $opcode( noop, NoopOp ),
  416.     (Nop =:= NoopOp ->
  417.       $buff_code(Clref,20,6 /*gs*/ ,Sop),    /* op code must be sob */
  418.           $opcode( switchonbound, SobOp ),
  419.       (Sop =:= SobOp ->                /* sob buffer */
  420.         $buff_code(Clref, 36, 8 /*gpb*/ ,Tclref),    /* first of all */
  421.         $db_get_clrefs(Tclref,N_clref,Dir)    /* and recurse */
  422.         ;
  423.         N_clref=Clref            /* not a sob buffer */
  424.       )
  425.       ;
  426.       N_clref=Clref
  427.     ).
  428.  
  429. $db_get_clrefs(Clref,N_clref,0) :- 
  430.     $db_get_next_clref(Clref,Nxt_clref),
  431.     $db_get_clrefs(Nxt_clref,N_clref,0).
  432.  
  433. /* get the next cl_ref following the given one. */
  434. $db_get_next_clref(Clref,Nxt_clref) :-
  435.         $opcode( retrymeelse, RetryOp ),
  436.     $buff_code(Clref,4,6 /*gs*/ ,B), 
  437.     (B =:= RetryOp, /* retrymeelse, so there is another clause */
  438.         $buff_code(Clref,8,8 /*gpb*/ ,Nxt_clref)
  439.      ;
  440.      B =\= RetryOp,
  441.           $opcode( trymeelse, TryOp ),
  442.       B =:= TryOp, /* trymeelse, so ditto */
  443.       $buff_code(Clref,8,8 /*gpb*/ ,Nxt_clref)
  444.     ).
  445.  
  446.  
  447. /* $db_kill_clause(Clref):  retracts the fact referenced by Clref.  It
  448. does this by simply making the first instruction of the clause a
  449. fail instruction. */
  450.  
  451. $db_kill_clause(Clref) :- 
  452.        $opcode( fail, FailOp ),
  453.        $buff_code(Clref, 12, 3 /*ps*/ ,FailOp /*fail*/ ).
  454.  
  455. /* ---------------------------------------------------------------------- */
  456.